home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 376-400 / disk_386 / xlispstat / src1.lzh / Headers / xlisp.h < prev    next >
C/C++ Source or Header  |  1990-10-03  |  12KB  |  353 lines
  1. #ifndef XLISP_H
  2. #define XLISP_H
  3.  
  4. /* xlisp - a small subset of lisp */
  5. /* Copyright (c) 1989, by David Michael Betz.                            */
  6. /* You may give out copies of this software; for conditions see the file */
  7. /* COPYING included with this distribution.                              */
  8.  
  9. #include <stdio.h>
  10. #include <ctype.h>
  11. #include <setjmp.h>
  12.  
  13. /* NNODES       number of nodes to allocate in each request (1000) */
  14. /* EDEPTH       evaluation stack depth (2000) */
  15. /* ADEPTH       argument stack depth (1000) */
  16. /* FORWARD      type of a forward declaration () */
  17. /* LOCAL        type of a local function (static) */
  18. /* AFMT         printf format for addresses ("%x") */
  19. /* FIXTYPE      data type for fixed point numbers (long) */
  20. /* ITYPE        fixed point input conversion routine type (long atol()) */
  21. /* ICNV         fixed point input conversion routine (atol) */
  22. /* IFMT         printf format for fixed point numbers ("%ld") */
  23. /* FLOTYPE      data type for floating point numbers (float) */
  24. /* OFFTYPE      number the size of an address (int) */
  25.  
  26. /* for the Turbo C compiler - MS-DOS, large model */
  27. #ifdef _TURBOC_
  28. #define NNODES          2000
  29. #define AFMT            "%lx"
  30. #define OFFTYPE         long
  31. #define SAVERESTORE
  32. #endif
  33.  
  34. /* for the AZTEC C compiler - MS-DOS, large model */
  35. #ifdef AZTEC_LM
  36. #define NNODES          2000
  37. #define AFMT            "%lx"
  38. #define OFFTYPE         long
  39. #define CVPTR(x)        ptrtoabs(x)
  40. #define NIL             (void *)0
  41. extern long ptrtoabs();
  42. #define SAVERESTORE
  43. #endif
  44.  
  45. /* for the AZTEC C compiler - Macintosh */
  46. #ifdef AZTEC_MAC
  47. #define NNODES          2000
  48. #define AFMT            "%lx"
  49. #define OFFTYPE         long
  50. #define NIL             (void *)0
  51. #define SAVERESTORE
  52. #endif
  53.  
  54. /* for the AZTEC C compiler - Amiga */
  55. #ifdef AZTEC_AMIGA
  56. #define NNODES          2000
  57. #define AFMT            "%lx"
  58. #define OFFTYPE         long
  59. #define NIL             (void *)0
  60. #define SAVERESTORE
  61. #endif
  62.  
  63. /* for the THINK C compiler - Macintosh */
  64. #ifdef THINK_C
  65. #define LSC
  66. #define NNODES          2000
  67. #define AFMT            "%lx"
  68. #define OFFTYPE         long
  69. #define NIL             (void *)0
  70. /*#define SAVERESTORE*/
  71. #ifndef MACINTOSH
  72. #define MACINTOSH
  73. #endif  MACINTOSH
  74. #endif  THINK_C
  75.  
  76. /* for the MPW C compiler - Macintosh */
  77. #ifdef MPWC
  78. #define LSC
  79. #define NNODES          2000
  80. #define AFMT            "%lx"
  81. #define OFFTYPE         long
  82. #define NIL             (void *)0
  83. /*#define SAVERESTORE*/
  84. #ifndef MACINTOSH
  85. #define MACINTOSH
  86. #endif  MACINTOSH
  87. # define newstring NEWSTRING /* to avoid a name conflict */
  88. # define SysBeep SYSBEEPMPW  /* to avoid a name conflict */
  89. #endif
  90.  
  91. /* for the UNIX C compiler */
  92. #ifdef UNIX
  93. /*#define SAVERESTORE*/
  94. #define NNODES          2000
  95. #endif
  96.  
  97. /* for the Microsoft C compiler - MS-DOS, large model */
  98. #ifdef MSC
  99. #define NNODES          2000
  100. #define AFMT            "%lx"
  101. #define OFFTYPE         long
  102. #endif
  103.  
  104. /* for the Mark Williams C compiler - Atari ST */
  105. #ifdef MWC
  106. #define AFMT            "%lx"
  107. #define OFFTYPE         long
  108. #endif
  109.  
  110. /* for the Lattice C compiler - Amiga and Atari ST */
  111. #ifdef LATTICE
  112. #define FIXTYPE         int
  113. #define ITYPE           int atoi()
  114. #define ICNV(n)         atoi(n)
  115. #define IFMT            "%d"
  116. #define SAVERESTORE    /* added by JKL */
  117. #endif
  118.  
  119. /* for the Digital Research C compiler - Atari ST */
  120. #ifdef DR
  121. #define LOCAL
  122. #define AFMT            "%lx"
  123. #define OFFTYPE     long
  124. #undef NULL
  125. #define NULL            0L
  126. #endif
  127.  
  128. /* default important definitions */
  129. #ifndef NNODES
  130. #define NNODES          1000
  131. #endif
  132. #ifndef EDEPTH
  133. #define EDEPTH          2000
  134. #endif
  135. #ifndef ADEPTH
  136. #define ADEPTH          1000
  137. #endif
  138. #ifndef FORWARD
  139. #define FORWARD
  140. #endif
  141. #ifndef LOCAL
  142. #define LOCAL           static
  143. #endif
  144. #ifndef AFMT
  145. #define AFMT            "%x"
  146. #endif
  147. #ifndef FIXTYPE
  148. #define FIXTYPE         long
  149. #endif
  150. #ifndef ITYPE
  151. #define ITYPE           long atol()
  152. #endif
  153. #ifndef ICNV
  154. #define ICNV(n)         atol(n)
  155. #endif
  156. #ifndef IFMT
  157. #define IFMT            "%ld"
  158. #endif
  159. #ifndef FLOTYPE
  160. #define FLOTYPE         double
  161. #endif
  162. #ifndef OFFTYPE
  163. #define OFFTYPE         int
  164. #endif
  165. #ifndef CVPTR
  166. #define CVPTR(x)        (x)
  167. #endif
  168. #ifndef UCHAR
  169. #define UCHAR           unsigned char
  170. #endif
  171.  
  172. /* useful definitions */
  173. #define TRUE    1
  174. #define FALSE   0
  175. #ifndef NIL
  176. #define NIL     (LVAL )0   /* this will not work since LVAL defined in */
  177. #endif                     /* xldmem.h below */
  178.  
  179. /* include the dynamic memory definitions */
  180. #include "xldmem.h"
  181.  
  182. /* program limits */
  183. #define STRMAX          1000            /* maximum length of a string constant */
  184. #define HSIZE           199             /* symbol hash table size */
  185. #define SAMPLE      100     /* control character sample rate */
  186.  
  187. /* function table offsets for the initialization functions */
  188. #define FT_RMHASH       0
  189. #define FT_RMQUOTE      1
  190. #define FT_RMDQUOTE     2
  191. #define FT_RMBQUOTE     3
  192. #define FT_RMCOMMA      4
  193. #define FT_RMLPAR       5
  194. #define FT_RMRPAR       6
  195. #define FT_RMSEMI       7
  196. #define FT_CLNEW        10
  197. #define FT_CLISNEW      11
  198. #define FT_CLANSWER     12
  199. #define FT_OBISNEW      13
  200. #define FT_OBCLASS      14
  201. #define FT_OBSHOW       15
  202.  
  203. /* macro to push a value onto the argument stack */
  204. #define pusharg(x)      {if (xlsp >= xlargstktop) xlargstkoverflow();\
  205.                          *xlsp++ = (x);}
  206.  
  207. /* macros to protect pointers */
  208. #define xlstkcheck(n)   {if (xlstack - (n) < xlstkbase) xlstkoverflow();}
  209. #define xlsave(n)       {*--xlstack = &n; n = NIL;}
  210. #define xlprotect(n)    {*--xlstack = &n;}
  211.  
  212. /* check the stack and protect a single pointer */
  213. #define xlsave1(n)      {if (xlstack <= xlstkbase) xlstkoverflow();\
  214.                          *--xlstack = &n; n = NIL;}
  215. #define xlprot1(n)      {if (xlstack <= xlstkbase) xlstkoverflow();\
  216.                          *--xlstack = &n;}
  217.  
  218. /* macros to pop pointers off the stack */
  219. #define xlpop()         {++xlstack;}
  220. #define xlpopn(n)       {xlstack+=(n);}
  221.  
  222. /* macros to manipulate the lexical environment */
  223. #define xlframe(e)      cons(NIL,e)
  224. #define xlbind(s,v)     xlpbind(s,v,xlenv)
  225. #define xlfbind(s,v)    xlpbind(s,v,xlfenv);
  226. #define xlpbind(s,v,e)  {rplaca(e,cons(cons(s,v),car(e)));}
  227.  
  228. /* macros to manipulate the dynamic environment */
  229. #define xldbind(s,v)    {xldenv = cons(cons(s,getvalue(s)),xldenv);\
  230.                          setvalue(s,v);}
  231. #define xlunbind(e)     {for (; xldenv != (e); xldenv = cdr(xldenv))\
  232.                            setvalue(car(car(xldenv)),cdr(car(xldenv)));}
  233.  
  234. /* type predicates */                  
  235. #define atom(x)         ((x) == NIL || ntype(x) != CONS)
  236. #define null(x)         ((x) == NIL)
  237. #define listp(x)        ((x) == NIL || ntype(x) == CONS)
  238. #define consp(x)        ((x) && ntype(x) == CONS)
  239. #define subrp(x)        ((x) && ntype(x) == SUBR)
  240. #define fsubrp(x)       ((x) && ntype(x) == FSUBR)
  241. #define stringp(x)      ((x) && ntype(x) == STRING)
  242. #define symbolp(x)      ((x) && ntype(x) == SYMBOL)
  243. #define streamp(x)      ((x) && ntype(x) == STREAM)
  244. #define objectp(x)      ((x) && ntype(x) == OBJECT)
  245. #define fixp(x)         ((x) && ntype(x) == FIXNUM)
  246. #define floatp(x)       ((x) && ntype(x) == FLONUM)
  247. #define vectorp(x)      ((x) && ntype(x) == VECTOR)
  248. #define closurep(x)     ((x) && ntype(x) == CLOSURE)
  249. #define charp(x)        ((x) && ntype(x) == CHAR)
  250. #define ustreamp(x)     ((x) && ntype(x) == USTREAM)
  251. #define complexp(x)     ((x) && ntype(x) == COMPLEX)       /* L. Tierney */
  252. #define structp(x)      ((x) && ntype(x) == STRUCT)
  253. #define boundp(x)       (getvalue(x) != s_unbound)
  254. #define fboundp(x)      (getfunction(x) != s_unbound)
  255. #define adatap(x)       ((x) && ntype(x) == ALLOCATED_DATA)  /* L. Tierney */
  256.  
  257. /* shorthand functions */
  258. #define consa(x)        cons(x,NIL)
  259. #define consd(x)        cons(NIL,x)
  260.  
  261. /* argument list parsing macros */
  262. #define xlgetarg()      (testarg(nextarg()))
  263. #define xllastarg()     {if (xlargc != 0) xltoomany();}
  264. #define testarg(e)      (moreargs() ? (e) : xltoofew())
  265. #define typearg(tp)     (tp(*xlargv) ? nextarg() : xlbadtype(*xlargv))
  266. #define nextarg()       (--xlargc, *xlargv++)
  267. #define moreargs()      (xlargc > 0)
  268.  
  269. /* macros to get arguments of a particular type */
  270. #define xlgacons()      (testarg(typearg(consp)))
  271. #define xlgalist()      (testarg(typearg(listp)))
  272. #define xlgasymbol()    (testarg(typearg(symbolp)))
  273. #define xlgastring()    (testarg(typearg(stringp)))
  274. #define xlgaobject()    (testarg(typearg(objectp)))
  275. #define xlgafixnum()    (testarg(typearg(fixp)))
  276. #define xlgaflonum()    (testarg(typearg(floatp)))
  277. #define xlgachar()      (testarg(typearg(charp)))
  278. #define xlgavector()    (testarg(typearg(vectorp)))
  279. #define xlgastream()    (testarg(typearg(streamp)))
  280. #define xlgaustream()   (testarg(typearg(ustreamp)))
  281. #define xlgaclosure()   (testarg(typearg(closurep)))
  282. #define xlgastruct()    (testarg(typearg(structp)))
  283.  
  284. /* function definition structure */
  285. typedef struct {
  286.     char *fd_name;      /* function name */
  287.     int fd_type;        /* function type */
  288.     LVAL (*fd_subr)();  /* function entry point */
  289. } FUNDEF;
  290.  
  291. /* execution context flags */
  292. #define CF_GO           0x0001
  293. #define CF_RETURN       0x0002
  294. #define CF_THROW        0x0004
  295. #define CF_ERROR        0x0008
  296. #define CF_CLEANUP      0x0010
  297. #define CF_CONTINUE     0x0020
  298. #define CF_TOPLEVEL     0x0040
  299. #define CF_BRKLEVEL     0x0080
  300. #define CF_UNWIND       0x0100
  301.  
  302. /* execution context */
  303. typedef struct context {
  304.     int c_flags;                        /* context type flags */
  305.     LVAL c_expr;                        /* expression (type dependant) */
  306.     jmp_buf c_jmpbuf;                   /* longjmp context */
  307.     struct context *c_xlcontext;        /* old value of xlcontext */
  308.     LVAL **c_xlstack;                   /* old value of xlstack */
  309.     LVAL *c_xlargv;                     /* old value of xlargv */
  310.     int c_xlargc;                       /* old value of xlargc */
  311.     LVAL *c_xlfp;                       /* old value of xlfp */
  312.     LVAL *c_xlsp;                       /* old value of xlsp */
  313.     LVAL c_xlenv;                       /* old value of xlenv */
  314.     LVAL c_xlfenv;                      /* old value of xlfenv */
  315.     LVAL c_xldenv;                      /* old value of xldenv */
  316. } CONTEXT;
  317.  
  318. /* external variables */
  319. extern LVAL **xlstktop;         /* top of the evaluation stack */
  320. extern LVAL **xlstkbase;        /* base of the evaluation stack */
  321. extern LVAL **xlstack;          /* evaluation stack pointer */
  322. extern LVAL *xlargstkbase;      /* base of the argument stack */
  323. extern LVAL *xlargstktop;       /* top of the argument stack */
  324. extern LVAL *xlfp;              /* argument frame pointer */
  325. extern LVAL *xlsp;              /* argument stack pointer */
  326. extern LVAL *xlargv;            /* current argument vector */
  327. extern int xlargc;              /* current argument count */
  328.  
  329. /* external procedure declarations */
  330. extern LVAL xleval();           /* evaluate an expression */
  331. extern LVAL xlapply();          /* apply a function to arguments */
  332. extern LVAL xlsubr();           /* enter a subr/fsubr */
  333. extern LVAL xlenter();          /* enter a symbol */
  334. extern LVAL xlmakesym();        /* make an uninterned symbol */
  335. extern LVAL xlgetvalue();       /* get value of a symbol (checked) */
  336. extern LVAL xlxgetvalue();      /* get value of a symbol */
  337. extern LVAL xlgetfunction();    /* get functional value of a symbol */
  338. extern LVAL xlxgetfunction();   /* get functional value of a symbol (checked) */
  339. extern LVAL xlexpandmacros();   /* expand macros in a form */
  340. extern LVAL xlgetprop();        /* get the value of a property */
  341. extern LVAL xlclose();          /* create a function closure */
  342.  
  343.  
  344. /* argument list parsing functions */
  345. extern LVAL xlgetfile();        /* get a file/stream argument */
  346. extern LVAL xlgetfname();       /* get a filename argument */
  347.  
  348. /* error reporting functions (don't *really* return at all) */
  349. extern LVAL xltoofew();         /* report "too few arguments" error */
  350. extern LVAL xlbadtype();        /* report "bad argument type" error */
  351.  
  352. #endif XLISP_H
  353.